Mastering Microsoft Visual Basic 5/Mastering Microsoft Visual Basic 5.ISO/demo code/ch11/wininet/frmmain.frm

Visual Basic Form | 1997-01-08 | 14.9 KB | 500 lines

VERSION 5.00
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.1#0"; "COMCTL32.OCX"
Begin VB.Form frmMain
   BorderStyle     =   3  'Fixed Dialog
   ClientHeight    =   4800
   ClientLeft      =   2820
   ClientTop       =   1935
   ClientWidth     =   6795
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4800
   ScaleWidth      =   6795
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdUser
      Caption         =   "Set User"
      Height          =   435
      Left            =   135
      TabIndex        =   18
      Top             =   2400
      Width           =   1095
   End
   Begin VB.CommandButton cmdCancel
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   435
      Left            =   4095
      TabIndex        =   21
      Top             =   2400
      Width           =   1095
   End
   Begin VB.CommandButton cmdClose
      Caption         =   "&Close"
      Height          =   435
      Left            =   5415
      TabIndex        =   22
      Top             =   2400
      Width           =   1095
   End
   Begin VB.ComboBox cboOperation
      Height          =   315
      Left            =   1185
      TabIndex        =   13
      Top             =   1950
      Width           =   2115
   End
   Begin VB.TextBox txtRequestHeaders
      Height          =   345
      Left            =   4575
      TabIndex        =   17
      Top             =   1950
      Width           =   2115
   End
   Begin VB.TextBox txtData
      Height          =   345
      Left            =   4575
      TabIndex        =   15
      Top             =   1500
      Width           =   2115
   End
   Begin VB.TextBox txtURL
      Height          =   345
      Left            =   1185
      TabIndex        =   11
      Top             =   1500
      Width           =   2115
   End
   Begin VB.CommandButton cmdOpenURL
      Caption         =   "&OpenURL"
      Height          =   435
      Left            =   1455
      TabIndex        =   19
      Top             =   2400
      Width           =   1095
   End
   Begin VB.CommandButton cmdExecute
      Caption         =   "E&xecute"
      Height          =   435
      Left            =   2775
      TabIndex        =   20
      Top             =   2400
      Width           =   1095
   End
   Begin VB.TextBox txtOutput
      Height          =   1500
      Left            =   105
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   23
      Top             =   2970
      Width           =   6585
   End
   Begin VB.Frame Frame2
      Caption         =   "Proxy Ty&pe"
      Height          =   675
      Left            =   3510
      TabIndex        =   4
      Top             =   90
      Width           =   3165
      Begin VB.OptionButton optProxy
         Caption         =   "&Default"
         Height          =   315
         Index           =   0
         Left            =   120
         TabIndex        =   5
         Top             =   270
         Value           =   -1  'True
         Width           =   900
      End
      Begin VB.OptionButton optProxy
         Caption         =   "Di&rect"
         Height          =   315
         Index           =   1
         Left            =   1200
         TabIndex        =   6
         Top             =   270
         Width           =   900
      End
      Begin VB.OptionButton optProxy
         Caption         =   "&Named"
         Height          =   315
         Index           =   2
         Left            =   2200
         TabIndex        =   7
         Top             =   270
         Width           =   900
      End
   End
   Begin VB.TextBox txtProxyServer
      Enabled         =   0   'False
      Height          =   345
      Left            =   4590
      TabIndex        =   9
      Top             =   900
      Width           =   2085
   End
   Begin InetCtlsObjects.Inet Inet1
      Left            =   7170
      Top             =   2160
      _ExtentX        =   1005
      _ExtentY        =   1005
   End
   Begin ComctlLib.StatusBar sbMain
      Align           =   2  'Align Bottom
      Height          =   285
      Left            =   0
      TabIndex        =   24
      Top             =   4515
      Width           =   6795
      _ExtentX        =   11986
      _ExtentY        =   503
      SimpleText      =   ""
      _Version        =   327680
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7}
         NumPanels       =   2
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            AutoSize        =   2
            TextSave        =   ""
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
         BeginProperty Panel2 {0713E89F-850A-101B-AFC0-4210102A8DA7}
            Alignment       =   2
            AutoSize        =   1
            Object.Width           =   9366
            TextSave        =   ""
            Key             =   ""
            Object.Tag             =   ""
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      MouseIcon       =   "frmMain.frx":0000
   End
   Begin VB.Label Label9
      Caption         =   "Req.&Headers:"
      Height          =   255
      Left            =   3525
      TabIndex        =   16
      Top             =   1980
      Width           =   975
   End
   Begin VB.Label Label8
      Caption         =   "&Data:"
      Height          =   255
      Left            =   3525
      TabIndex        =   14
      Top             =   1530
      Width           =   975
   End
   Begin VB.Label lblRemotePort
      BorderStyle     =   1  'Fixed Single
      Height          =   345
      Left            =   1170
      TabIndex        =   3
      Top             =   600
      Width           =   2085
   End
   Begin VB.Label Label7
      Caption         =   "Remote Port:"
      Height          =   255
      Left            =   90
      TabIndex        =   2
      Top             =   630
      Width           =   975
   End
   Begin VB.Label lblRemoteHost
      BorderStyle     =   1  'Fixed Single
      Height          =   345
      Left            =   1170
      TabIndex        =   1
      Top             =   90
      Width           =   2085
   End
   Begin VB.Label Label6
      Caption         =   "&URL:"
      Height          =   255
      Left            =   135
      TabIndex        =   10
      Top             =   1530
      Width           =   975
   End
   Begin VB.Label Label5
      Caption         =   "&Execute Op:"
      Height          =   255
      Left            =   135
      TabIndex        =   12
      Top             =   1980
      Width           =   975
   End
   Begin VB.Line Line2
      BorderWidth     =   2
      X1              =   15
      X2              =   6945
      Y1              =   1350
      Y2              =   1350
   End
   Begin VB.Label Label4
      Caption         =   "Proxy &Server:"
      Height          =   255
      Left            =   3510
      TabIndex        =   8
      Top             =   930
      Width           =   975
   End
   Begin VB.Label Label1
      Caption         =   "Remote Host:"
      Height          =   255
      Left            =   90
      TabIndex        =   0
      Top             =   120
      Width           =   975
   End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Enum Protocol
  ptlNONE
  ptlFTP
  ptlHTTP
End Enum
Dim ptl As Protocol
Dim lAccessType As Long
Dim bResponseCompleted As Boolean
Dim strStateChange(0 To 12) As String
Private Function SetProxyProperties() As Boolean
  SetProxyProperties = True
  With Inet1
    ' Set Proxy Properties
    If lAccessType = icNamedProxy Then
      If Len(txtProxyServer) = 0 Then
        MsgBox "Enter proxy server"
        txtProxyServer.SetFocus
        SetProxyProperties = False
        Exit Function
      End If
      .Proxy = txtProxyServer
    End If
    .AccessType = lAccessType
  End With
End Function
Private Sub cmdCancel_Click()
  ' Cancel the current operation
  If Inet1.StillExecuting Then Inet1.Cancel
  cmdOpenURL.Enabled = True
  cmdExecute.Enabled = True
End Sub
Private Sub cmdClose_Click()
  If Inet1.StillExecuting Then Inet1.Cancel
  Unload Me
End Sub
Private Sub cmdExecute_Click()
  On Error GoTo Errhandler
  If Not ValidOperation Then
    cboOperation.SetFocus
    Exit Sub
  End If
  SetProxyProperties
  DisplayConnectInfo
  Inet1.URL = txtURL
  bResponseCompleted = False
  txtOutput = ""
  ' If the protocol is FTP, execute with the choosen operation.
  If ptl = ptlFTP Then
    If Len(cboOperation.Text) = 0 Then
      MsgBox "You must choose an FTP operation"
      cboOperation.SetFocus
      Exit Sub
    End If
    Inet1.Execute , "" & cboOperation & ""
  ElseIf ptl = ptlHTTP Then
    If Len(cboOperation.Text) = 0 Then
      MsgBox "You must choose an HTTP operation"
      cboOperation.SetFocus
      Exit Sub
    End If
    Inet1.Execute txtURL, "" & cboOperation & "" _
      , "" & txtData & "", "" & txtRequestHeaders & ""
  Else
    MsgBox "Invalid Protocol Type. Preface your URL with" & _
      " 'ftp://' or 'http://'"
    txtURL.SetFocus
    Exit Sub
  End If
  cmdOpenURL.Enabled = False
  cmdExecute.Enabled = False
  While Inet1.StillExecuting
    DoEvents
  Wend
  cmdOpenURL.Enabled = True
  cmdExecute.Enabled = True
  Exit Sub
Errhandler:
  MsgBox "Error on Execute" & vbCrLf & Err.Description
  cmdOpenURL.Enabled = True
  cmdExecute.Enabled = True
End Sub
Private Sub Inet1_StateChanged(ByVal State As Integer)
  DisplayStateStatus (State)
  Debug.Print "State Change: " & strStateChange(State)
  Select Case State
    Case icResponseCompleted
      Dim s As String
      ' Get the first chunk.
      s = Inet1.GetChunk(1024)

      Do While Len(s) > 0
        txtOutput = txtOutput & s
        s = Inet1.GetChunk(1024)
      Loop
      bResponseCompleted = True
    Case icError
      Debug.Print "An FTP Error Occurred"
      MsgBox "No.: " & Inet1.ResponseCode & vbCrLf & _
        "Desc.: " & Inet1.ResponseInfo, , "Execute Error"
  End Select
End Sub
Private Sub cmdOpenURL_Click()
  On Error GoTo Errhandler
  SetProxyProperties
  ' If Len(txtURL) Then Inet1.URL = txtURL
  txtOutput = Inet1.OpenURL("" & txtURL & "")
  DisplayConnectInfo
  Exit Sub
Errhandler:
  MsgBox "Error on Execute" & vbCrLf & Err.Description
End Sub
Private Sub cmdUser_Click()
  ' Display the User logon form
  frmLogin.Show 1, Me
End Sub
Private Sub Form_Load()
  lAccessType = icUseDefault
  InitStateChangeString
  ptl = ptlNONE
End Sub
Private Sub optProxy_Click(Index As Integer)
  ' Store the current proxy selection
  lAccessType = Index
  ' Disable the proxy server textbox is not a named proxy
  If Index = icNamedProxy Then
    txtProxyServer.Enabled = True
    txtProxyServer.SetFocus
  Else
    txtProxyServer.Enabled = False
  End If
End Sub
Private Sub txtURL_Change()
  cmdOpenURL.Enabled = Len(txtURL)
  If UCase$(Left$(txtURL, 6)) = "FTP://" And ptl <> ptlFTP Then
    ptl = ptlFTP
    FillFTPOperations
    cboOperation.ListIndex = 1
  ElseIf UCase$(Left$(txtURL, 7)) = "HTTP://" And ptl <> ptlHTTP Then
    ptl = ptlHTTP
    FillHTTPOperations
    cboOperation.ListIndex = 1
  ElseIf UCase$(Left$(txtURL, 6)) <> "FTP://" And _
      UCase$(Left$(txtURL, 7)) <> "HTTP://" Then
    ptl = ptlNONE
    cboOperation.Clear
  End If
End Sub
Private Sub InitStateChangeString()
  strStateChange(0) = ""
  strStateChange(1) = "Resolving Host..."
  strStateChange(2) = "Host Resolved"
  strStateChange(3) = "Connecting..."
  strStateChange(4) = "Connected"
  strStateChange(5) = "Requesting..."
  strStateChange(6) = "Request Sent"
  strStateChange(7) = "Receiving Response..."
  strStateChange(8) = "Response Received"
  strStateChange(9) = "Disconnecting..."
  strStateChange(10) = "Disconnected"
  strStateChange(11) = "Error"
  strStateChange(12) = "Response Completed"
End Sub
Private Sub DisplayStateStatus(ByVal State As Integer)
  Debug.Assert State >= 0 And State < 13
  sbMain.Panels(1).Text = strStateChange(State)
End Sub
Private Sub FillFTPOperations()
  cboOperation.Clear
  cboOperation.AddItem "CD <file1>"
  cboOperation.AddItem "CDUP "
  cboOperation.AddItem "DELETE <file1>"
  cboOperation.AddItem "DIR [file1]"
  cboOperation.AddItem "GET <file1> <file2>"
  cboOperation.AddItem "MKDIR <dir1>"
  cboOperation.AddItem "PUT <file1> <file2>"
  cboOperation.AddItem "PWD "
  cboOperation.AddItem "QUIT "
  cboOperation.AddItem "RENAME <file1> <file2>"
  cboOperation.AddItem "RMDIR <dir1>"
  cboOperation.AddItem "SIZE <file1>"
End Sub
Private Sub FillHTTPOperations()
  cboOperation.Clear
  cboOperation.AddItem "GET"
  cboOperation.AddItem "HEAD"
  cboOperation.AddItem "POST"
  cboOperation.AddItem "PUT"
End Sub
Private Function ValidOperation() As Boolean
  Dim posStart As Integer
  Dim pos As Integer
  ValidOperation = True
  ' Search for mandatory parameters not set
  posStart = 1
  pos = InStr(posStart, cboOperation.Text, "<", vbTextCompare)
  If pos Then
    cboOperation.SelStart = pos - 1
    posStart = pos + 1
    pos = InStr(posStart, cboOperation, ">", vbTextCompare)
    If pos > 0 Then
      ValidOperation = False
      cboOperation.SelLength = pos - cboOperation.SelStart + 1
    Else
      cboOperation.SelLength = 999
    End If
    ValidOperation = False
    Exit Function
  End If
  ' Check for any optional parameters
  posStart = 1
  pos = InStr(posStart, cboOperation, "[", vbTextCompare)
  While pos
    If pos Then
      cboOperation.SelStart = pos - 1
      posStart = pos + 1
      pos = InStr(posStart, cboOperation, "]", vbTextCompare)
      If pos Then
        cboOperation.SelLength = pos - cboOperation.SelStart + 1
        cboOperation.SelText = ""
      Else
        Exit Function
      End If
    End If
    posStart = 1
    pos = InStr(posStart, cboOperation, "[")
  Wend
End Function
Private Sub DisplayConnectInfo()
  lblRemoteHost = Inet1.RemoteHost
  lblRemotePort = Inet1.RemotePort
End Sub